library(tidyverse)

Payoff function


R0 <- 2

#pi is the probability (0~1) of being infected in the steady state with vaccination fraction of p.
pi <- function(p = 0.5, R0 = 2) {
  val = 1 - (1/(R0 * (1-p)))
  return(ifelse(val < 0, 0, ifelse(p >= P_crit(R0), 0, val)))
}

#r is the probability ratio of probability of getting vaccine related adverse outcome and disease related adverse outcome. r < 0 means percived risk of vaccination is lesser than that of disease itself
payoff <- function(P = 0.5, p = 0.5, r = 0.2, R0 = 2) {
  -(r*P) - (pi(p, R0)*(1-P))
}

#A sigma proportion is vaccinated with P probability and the rest with Q probability.
payoff_gain <- function(P, Q, sigma, rp = 0.2, rq = 0.2 ,R0 = 2) {
  
  #p is the overall proportion of vaccinated people
  p = sigma*P + ((1-sigma)*Q)
  
  EP = payoff(P = P, p = p, r = rp, R0 = R0)
  EQ = payoff(P = Q, p = p, r = rq,  R0 = R0)
  
  EP - EQ
}

#NE probability. If r > Pi(0), no one would vaccinate and csne_p will be 0.
csne_P <- function(r, R0 = 2) {
  val = 1 - (1/(R0*(1-r)))
  return(ifelse(val < 0, 0, ifelse(r >= pi(p = 0, R0), 0, val)))
}

P_crit <- function(R0 = 2) {
  p = 0
  if (R0 > 1){
    p = 1 - (1/R0)
  }
  p
}

csne_payoff <- function(r, R0) {
  P = csne_P(r = r, R0 = R0)
  p = P
  payoff(P,p,r,R0)
}
#As long as the percieved risk r = 0 and p < Pcritic, expected individual payoff ifcreases with P

If P is a Nash equilibrium, and everyone is currently playing P, then no one should change strategy. If P is convergently stable, then regardless of what strategy is most common in the population, individuals should start to play strategies closer to P, and ultimately adopt P.

R0 <- 2
sigma <- 0.6
r <- 0.1
P <- seq(0,1, 0.01)
Q <- seq(0,1, by = 0.01)
ggplotly(expand_grid(P,Q) %>% mutate(gain = payoff_gain(P = P, Q = Q, sigma = sigma, rp = r, rq = r, R0 = R0)) %>% ggplot(aes(P, gain, col = Q)) + geom_line(aes(group = Q)) + geom_hline(yintercept = 0) + geom_vline(xintercept = csne_P(r, R0)))
theme_set(theme_bw())
rs <- seq(0,1.5,by=0.01)
R0s <- c(2,5,10,20)
df <- expand.grid(rs,R0s) %>% rename(r = Var1, R0 = Var2)
df %>% mutate(p_star = csne_P(r = r, R0 = R0)) %>% ggplot(aes(r, p_star, group = R0)) + geom_line(aes(linetype = as.factor(R0)))
Warning: Problem while computing `p_star = csne_P(r = r, R0 = R0)`.
ℹ the condition has length > 1 and only the first element will be used

rs <- seq(0,2,by=0.01)
R0s <- c(2,5,10, 20)
df <- expand.grid(rs,R0s) %>% rename(r = Var1, R0 = Var2)
df %>% mutate(p_fixed = csne_P(r = 1, R0 = R0), p_exp = csne_P(r = r, R0 = R0), delta = p_exp - p_fixed) %>% ggplot(aes(r, delta, lineltye = as.factor(R0))) + geom_line(aes(linetype = as.factor(R0)))
Warning: Problem while computing `p_exp = csne_P(r = r, R0 = R0)`.
ℹ the condition has length > 1 and only the first element will be used

Analysis of vaccine scares: payoff gain, ΔE, and change in vaccine uptake, ΔP, after a shift in risk perception from r < π0 to r′ (see Table 1). For this figure, r = 0.1 and the proportion of individuals currently adopting the new CSNE is ε = 0 (corresponding to the start of a vaccine scare); the shapes of the curves are qualitatively similar for other values of r and ε.

rs <- seq(0,1.5,by=0.01)
R0s <- c(2,5,10, 20)
sigma = 0
old_risk = .1

df <- expand.grid(rs,R0s) %>% rename(r = Var1, R0 = Var2)
df %>% 
    mutate(p_fixed = csne_P(r = old_risk, R0 = R0), 
           p_exp = csne_P(r = r, R0 = R0), 
           delta = p_exp - p_fixed, 
           e_gain = payoff_gain(P = p_exp, Q = p_fixed, sigma = sigma, rp = r, rq = r, R0 = R0)) %>% pivot_longer(., cols = c(delta, e_gain), names_to = 'nam', values_to = 'vals') %>% 
    ggplot(aes(r, vals, lineltye = as.factor(R0), col = nam)) + 
    geom_line(aes(linetype = as.factor(-R0)))
Warning: Problem while computing `p_fixed = csne_P(r = old_risk, R0 = R0)`.
ℹ the condition has length > 1 and only the first element will be used
Warning: Problem while computing `p_exp = csne_P(r = r, R0 = R0)`.
ℹ the condition has length > 1 and only the first element will be used
Warning: Problem while computing `e_gain = payoff_gain(...)`.
ℹ the condition has length > 1 and only the first element will be used
Warning: Problem while computing `e_gain = payoff_gain(...)`.
ℹ the condition has length > 1 and only the first element will be used

LS0tCnRpdGxlOiAiUiBOb3RlYm9vayIKb3V0cHV0OiBodG1sX25vdGVib29rCi0tLQoKCmBgYHtyIG1lc3NhZ2U9RkFMU0UsIHdhcm5pbmc9RkFMU0V9CmxpYnJhcnkodGlkeXZlcnNlKQpgYGAKCgpQYXlvZmYgZnVuY3Rpb24KYGBge3J9CgpSMCA8LSAyCgojcGkgaXMgdGhlIHByb2JhYmlsaXR5ICgwfjEpIG9mIGJlaW5nIGluZmVjdGVkIGluIHRoZSBzdGVhZHkgc3RhdGUgd2l0aCB2YWNjaW5hdGlvbiBmcmFjdGlvbiBvZiBwLgpwaSA8LSBmdW5jdGlvbihwID0gMC41LCBSMCA9IDIpIHsKICB2YWwgPSAxIC0gKDEvKFIwICogKDEtcCkpKQogIHJldHVybihpZmVsc2UodmFsIDwgMCwgMCwgaWZlbHNlKHAgPj0gUF9jcml0KFIwKSwgMCwgdmFsKSkpCn0KCiNyIGlzIHRoZSBwcm9iYWJpbGl0eSByYXRpbyBvZiBwcm9iYWJpbGl0eSBvZiBnZXR0aW5nIHZhY2NpbmUgcmVsYXRlZCBhZHZlcnNlIG91dGNvbWUgYW5kIGRpc2Vhc2UgcmVsYXRlZCBhZHZlcnNlIG91dGNvbWUuIHIgPCAwIG1lYW5zIHBlcmNpdmVkIHJpc2sgb2YgdmFjY2luYXRpb24gaXMgbGVzc2VyIHRoYW4gdGhhdCBvZiBkaXNlYXNlIGl0c2VsZgpwYXlvZmYgPC0gZnVuY3Rpb24oUCA9IDAuNSwgcCA9IDAuNSwgciA9IDAuMiwgUjAgPSAyKSB7CiAgLShyKlApIC0gKHBpKHAsIFIwKSooMS1QKSkKfQoKI0Egc2lnbWEgcHJvcG9ydGlvbiBpcyB2YWNjaW5hdGVkIHdpdGggUCBwcm9iYWJpbGl0eSBhbmQgdGhlIHJlc3Qgd2l0aCBRIHByb2JhYmlsaXR5LgpwYXlvZmZfZ2FpbiA8LSBmdW5jdGlvbihQLCBRLCBzaWdtYSwgcnAgPSAwLjIsIHJxID0gMC4yICxSMCA9IDIpIHsKICAKICAjcCBpcyB0aGUgb3ZlcmFsbCBwcm9wb3J0aW9uIG9mIHZhY2NpbmF0ZWQgcGVvcGxlCiAgcCA9IHNpZ21hKlAgKyAoKDEtc2lnbWEpKlEpCiAgCiAgRVAgPSBwYXlvZmYoUCA9IFAsIHAgPSBwLCByID0gcnAsIFIwID0gUjApCiAgRVEgPSBwYXlvZmYoUCA9IFEsIHAgPSBwLCByID0gcnEsICBSMCA9IFIwKQogIAogIEVQIC0gRVEKfQoKI05FIHByb2JhYmlsaXR5LiBJZiByID4gUGkoMCksIG5vIG9uZSB3b3VsZCB2YWNjaW5hdGUgYW5kIGNzbmVfcCB3aWxsIGJlIDAuCmNzbmVfUCA8LSBmdW5jdGlvbihyLCBSMCA9IDIpIHsKICB2YWwgPSAxIC0gKDEvKFIwKigxLXIpKSkKICByZXR1cm4oaWZlbHNlKHZhbCA8IDAsIDAsIGlmZWxzZShyID49IHBpKHAgPSAwLCBSMCksIDAsIHZhbCkpKQp9CgpQX2NyaXQgPC0gZnVuY3Rpb24oUjAgPSAyKSB7CiAgcCA9IDAKICBpZiAoUjAgPiAxKXsKICAgIHAgPSAxIC0gKDEvUjApCiAgfQogIHAKfQoKY3NuZV9wYXlvZmYgPC0gZnVuY3Rpb24ociwgUjApIHsKICBQID0gY3NuZV9QKHIgPSByLCBSMCA9IFIwKQogIHAgPSBQCiAgcGF5b2ZmKFAscCxyLFIwKQp9CiNBcyBsb25nIGFzIHRoZSBwZXJjaWV2ZWQgcmlzayByID0gMCBhbmQgcCA8IFBjcml0aWMsIGV4cGVjdGVkIGluZGl2aWR1YWwgcGF5b2ZmIGlmY3JlYXNlcyB3aXRoIFAKYGBgCgpJZiBQIGlzIGEgTmFzaCBlcXVpbGlicml1bSwgYW5kIGV2ZXJ5b25lIGlzIGN1cnJlbnRseSBwbGF5aW5nIFAsIHRoZW4gbm8gb25lIHNob3VsZCBjaGFuZ2Ugc3RyYXRlZ3kuIElmIFAgaXMgY29udmVyZ2VudGx5IHN0YWJsZSwgdGhlbiByZWdhcmRsZXNzIG9mIHdoYXQgc3RyYXRlZ3kgaXMgbW9zdCBjb21tb24gaW4gdGhlIHBvcHVsYXRpb24sIGluZGl2aWR1YWxzIHNob3VsZCBzdGFydCB0byBwbGF5IHN0cmF0ZWdpZXMgY2xvc2VyIHRvIFAsIGFuZCB1bHRpbWF0ZWx5IGFkb3B0IFAuCgpgYGB7cn0KUjAgPC0gMgpzaWdtYSA8LSAwLjYKciA8LSAwLjEKUCA8LSBzZXEoMCwxLCAwLjAxKQpRIDwtIHNlcSgwLDEsIGJ5ID0gMC4wMSkKZ2dwbG90bHkoZXhwYW5kX2dyaWQoUCxRKSAlPiUgbXV0YXRlKGdhaW4gPSBwYXlvZmZfZ2FpbihQID0gUCwgUSA9IFEsIHNpZ21hID0gc2lnbWEsIHJwID0gciwgcnEgPSByLCBSMCA9IFIwKSkgJT4lIGdncGxvdChhZXMoUCwgZ2FpbiwgY29sID0gUSkpICsgZ2VvbV9saW5lKGFlcyhncm91cCA9IFEpKSArIGdlb21faGxpbmUoeWludGVyY2VwdCA9IDApICsgZ2VvbV92bGluZSh4aW50ZXJjZXB0ID0gY3NuZV9QKHIsIFIwKSkpCmBgYAoKCmBgYHtyfQp0aGVtZV9zZXQodGhlbWVfYncoKSkKcnMgPC0gc2VxKDAsMS41LGJ5PTAuMDEpClIwcyA8LSBjKDIsNSwxMCwyMCkKZGYgPC0gZXhwYW5kLmdyaWQocnMsUjBzKSAlPiUgcmVuYW1lKHIgPSBWYXIxLCBSMCA9IFZhcjIpCmRmICU+JSBtdXRhdGUocF9zdGFyID0gY3NuZV9QKHIgPSByLCBSMCA9IFIwKSkgJT4lIGdncGxvdChhZXMociwgcF9zdGFyLCBncm91cCA9IFIwKSkgKyBnZW9tX2xpbmUoYWVzKGxpbmV0eXBlID0gYXMuZmFjdG9yKFIwKSkpCmBgYAoKYGBge3J9CnJzIDwtIHNlcSgwLDIsYnk9MC4wMSkKUjBzIDwtIGMoMiw1LDEwLCAyMCkKZGYgPC0gZXhwYW5kLmdyaWQocnMsUjBzKSAlPiUgcmVuYW1lKHIgPSBWYXIxLCBSMCA9IFZhcjIpCmRmICU+JSBtdXRhdGUocF9maXhlZCA9IGNzbmVfUChyID0gMSwgUjAgPSBSMCksIHBfZXhwID0gY3NuZV9QKHIgPSByLCBSMCA9IFIwKSwgZGVsdGEgPSBwX2V4cCAtIHBfZml4ZWQpICU+JSBnZ3Bsb3QoYWVzKHIsIGRlbHRhLCBsaW5lbHR5ZSA9IGFzLmZhY3RvcihSMCkpKSArIGdlb21fbGluZShhZXMobGluZXR5cGUgPSBhcy5mYWN0b3IoUjApKSkKYGBgCgoKQW5hbHlzaXMgb2YgdmFjY2luZSBzY2FyZXM6IHBheW9mZiBnYWluLCDOlEUsIGFuZCBjaGFuZ2UgaW4gdmFjY2luZSB1cHRha2UsIM6UUCwgYWZ0ZXIgYSBzaGlmdCBpbiByaXNrIHBlcmNlcHRpb24gZnJvbSByIDwgz4AwIHRvIHLigLIgKHNlZSBUYWJsZSAxKS4gRm9yIHRoaXMgZmlndXJlLCByID0gMC4xIGFuZCB0aGUgcHJvcG9ydGlvbiBvZiBpbmRpdmlkdWFscyBjdXJyZW50bHkgYWRvcHRpbmcgdGhlIG5ldyBDU05FIGlzIM61ID0gMCAoY29ycmVzcG9uZGluZyB0byB0aGUgc3RhcnQgb2YgYSB2YWNjaW5lIHNjYXJlKTsgdGhlIHNoYXBlcyBvZiB0aGUgY3VydmVzIGFyZSBxdWFsaXRhdGl2ZWx5IHNpbWlsYXIgZm9yIG90aGVyIHZhbHVlcyBvZiByIGFuZCDOtS4KYGBge3J9CnJzIDwtIHNlcSgwLDEuNSxieT0wLjAxKQpSMHMgPC0gYygyLDUsMTAsIDIwKQpzaWdtYSA9IDAKb2xkX3Jpc2sgPSAuMQoKZGYgPC0gZXhwYW5kLmdyaWQocnMsUjBzKSAlPiUgcmVuYW1lKHIgPSBWYXIxLCBSMCA9IFZhcjIpCmRmICU+JSAKICAgIG11dGF0ZShwX2ZpeGVkID0gY3NuZV9QKHIgPSBvbGRfcmlzaywgUjAgPSBSMCksIAogICAgICAgICAgIHBfZXhwID0gY3NuZV9QKHIgPSByLCBSMCA9IFIwKSwgCiAgICAgICAgICAgZGVsdGEgPSBwX2V4cCAtIHBfZml4ZWQsIAogICAgICAgICAgIGVfZ2FpbiA9IHBheW9mZl9nYWluKFAgPSBwX2V4cCwgUSA9IHBfZml4ZWQsIHNpZ21hID0gc2lnbWEsIHJwID0gciwgcnEgPSByLCBSMCA9IFIwKSkgJT4lIHBpdm90X2xvbmdlciguLCBjb2xzID0gYyhkZWx0YSwgZV9nYWluKSwgbmFtZXNfdG8gPSAnbmFtJywgdmFsdWVzX3RvID0gJ3ZhbHMnKSAlPiUgCiAgICBnZ3Bsb3QoYWVzKHIsIHZhbHMsIGxpbmVsdHllID0gYXMuZmFjdG9yKFIwKSwgY29sID0gbmFtKSkgKyAKICAgIGdlb21fbGluZShhZXMobGluZXR5cGUgPSBhcy5mYWN0b3IoLVIwKSkpCmBgYAoKCg==